home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1993 July / InfoMagic USENET CD-ROM July 1993.ISO / sources / unix / volume1 / xlisp1.4 / part2 < prev    next >
Encoding:
Internet Message Format  |  1986-11-30  |  59.9 KB
  1. Date: Wed, 13 Mar 85 16:54:45 pst
  2. From: decvax!ucbvax!UCBJADE!ucbjade:mwm (Mike Meyer)
  3. Subject: XLISP 1.4 part 2 (of 4)
  4.  
  5.  
  6. #! /bin/sh
  7. # This is a shell archive, meaning:
  8. # 1. Remove everything above the #! /bin/sh line.
  9. # 2. Save the resulting text in a file.
  10. # 3. Execute the file with /bin/sh (not csh) to create the files:
  11. #    xlbfun.c
  12. #    xlcont.c
  13. #    xllist.c
  14. #    xlobj.c
  15. # This archive created: Mon Dec  2 10:13:10 1985
  16. export PATH; PATH=/bin:$PATH
  17. echo shar: extracting "'xlbfun.c'" '(8689 characters)'
  18. if test -f 'xlbfun.c'
  19. then
  20.     echo shar: will not over-write existing file "'xlbfun.c'"
  21. else
  22. sed 's/^X//' << \SHAR_EOF > 'xlbfun.c'
  23. /* xlbfun.c - xlisp basic builtin functions */
  24.  
  25. #include "xlisp.h"
  26.  
  27. /* external variables */
  28. extern NODE *xlstack;
  29. extern NODE *s_lambda,*s_macro;
  30. extern NODE *s_comma,*s_comat;
  31. extern NODE *s_unbound;
  32. extern char gsprefix[];
  33. extern int gsnumber;
  34.  
  35. /* forward declarations */
  36. XFORWARD NODE *bquote1();
  37. XFORWARD NODE *defun();
  38. XFORWARD NODE *makesymbol();
  39.  
  40. /* xeval - the builtin function 'eval' */
  41. NODE *xeval(args)
  42.   NODE *args;
  43. {
  44.     NODE *oldstk,expr,*val;
  45.  
  46.     /* create a new stack frame */
  47.     oldstk = xlsave(&expr,NULL);
  48.  
  49.     /* get the expression to evaluate */
  50.     expr.n_ptr = xlarg(&args);
  51.     xllastarg(args);
  52.  
  53.     /* evaluate the expression */
  54.     val = xleval(expr.n_ptr);
  55.  
  56.     /* restore the previous stack frame */
  57.     xlstack = oldstk;
  58.  
  59.     /* return the expression evaluated */
  60.     return (val);
  61. }
  62.  
  63. /* xapply - the builtin function 'apply' */
  64. NODE *xapply(args)
  65.   NODE *args;
  66. {
  67.     NODE *oldstk,fun,arglist,*val;
  68.  
  69.     /* create a new stack frame */
  70.     oldstk = xlsave(&fun,&arglist,NULL);
  71.  
  72.     /* get the function and argument list */
  73.     fun.n_ptr = xlarg(&args);
  74.     arglist.n_ptr = xlarg(&args);
  75.     xllastarg(args);
  76.  
  77.     /* if the function is a symbol, get its value */
  78.     if (symbolp(fun.n_ptr))
  79.     fun.n_ptr = xleval(fun.n_ptr);
  80.  
  81.     /* apply the function to the arguments */
  82.     val = xlapply(fun.n_ptr,arglist.n_ptr);
  83.  
  84.     /* restore the previous stack frame */
  85.     xlstack = oldstk;
  86.  
  87.     /* return the expression evaluated */
  88.     return (val);
  89. }
  90.  
  91. /* xfuncall - the builtin function 'funcall' */
  92. NODE *xfuncall(args)
  93.   NODE *args;
  94. {
  95.     NODE *oldstk,fun,arglist,*val;
  96.  
  97.     /* create a new stack frame */
  98.     oldstk = xlsave(&fun,&arglist,NULL);
  99.  
  100.     /* get the function and argument list */
  101.     fun.n_ptr = xlarg(&args);
  102.     arglist.n_ptr = args;
  103.  
  104.     /* if the function is a symbol, get its value */
  105.     if (symbolp(fun.n_ptr))
  106.     fun.n_ptr = xleval(fun.n_ptr);
  107.  
  108.     /* apply the function to the arguments */
  109.     val = xlapply(fun.n_ptr,arglist.n_ptr);
  110.  
  111.     /* restore the previous stack frame */
  112.     xlstack = oldstk;
  113.  
  114.     /* return the expression evaluated */
  115.     return (val);
  116. }
  117.  
  118. /* xquote - builtin function to quote an expression */
  119. NODE *xquote(args)
  120.   NODE *args;
  121. {
  122.     NODE *arg;
  123.  
  124.     /* get the argument */
  125.     arg = xlarg(&args);
  126.     xllastarg(args);
  127.  
  128.     /* return the quoted expression */
  129.     return (arg);
  130. }
  131.  
  132. /* xbquote - back quote function */
  133. NODE *xbquote(args)
  134.   NODE *args;
  135. {
  136.     NODE *oldstk,expr,*val;
  137.  
  138.     /* create a new stack frame */
  139.     oldstk = xlsave(&expr,NULL);
  140.  
  141.     /* get the expression */
  142.     expr.n_ptr = xlarg(&args);
  143.     xllastarg(args);
  144.  
  145.     /* fill in the template */
  146.     val = bquote1(expr.n_ptr);
  147.  
  148.     /* restore the previous stack frame */
  149.     xlstack = oldstk;
  150.  
  151.     /* return the result */
  152.     return (val);
  153. }
  154.  
  155. /* bquote1 - back quote helper function */
  156. LOCAL NODE *bquote1(expr)
  157.   NODE *expr;
  158. {
  159.     NODE *oldstk,val,list,*last,*new;
  160.  
  161.     /* handle atoms */
  162.     if (atom(expr))
  163.     val.n_ptr = expr;
  164.  
  165.     /* handle (comma <expr>) */
  166.     else if (car(expr) == s_comma) {
  167.     if (atom(cdr(expr)))
  168.         xlfail("bad comma expression");
  169.     val.n_ptr = xleval(car(cdr(expr)));
  170.     }
  171.  
  172.     /* handle ((comma-at <expr>) ... ) */
  173.     else if (consp(car(expr)) && car(car(expr)) == s_comat) {
  174.     oldstk = xlsave(&list,&val,NULL);
  175.     if (atom(cdr(car(expr))))
  176.         xlfail("bad comma-at expression");
  177.     list.n_ptr = xleval(car(cdr(car(expr))));
  178.     for (last = NIL; consp(list.n_ptr); list.n_ptr = cdr(list.n_ptr)) {
  179.         new = newnode(LIST);
  180.         rplaca(new,car(list.n_ptr));
  181.         if (last)
  182.         rplacd(last,new);
  183.         else
  184.         val.n_ptr = new;
  185.         last = new;
  186.     }
  187.     if (last)
  188.         rplacd(last,bquote1(cdr(expr)));
  189.     else
  190.         val.n_ptr = bquote1(cdr(expr));
  191.     xlstack = oldstk;
  192.     }
  193.  
  194.     /* handle any other list */
  195.     else {
  196.     oldstk = xlsave(&val,NULL);
  197.     val.n_ptr = newnode(LIST);
  198.     rplaca(val.n_ptr,bquote1(car(expr)));
  199.     rplacd(val.n_ptr,bquote1(cdr(expr)));
  200.     xlstack = oldstk;
  201.     }
  202.  
  203.     /* return the result */
  204.     return (val.n_ptr);
  205. }
  206.  
  207. /* xset - builtin function set */
  208. NODE *xset(args)
  209.   NODE *args;
  210. {
  211.     NODE *sym,*val;
  212.  
  213.     /* get the symbol and new value */
  214.     sym = xlmatch(SYM,&args);
  215.     val = xlarg(&args);
  216.     xllastarg(args);
  217.  
  218.     /* assign the symbol the value of argument 2 and the return value */
  219.     assign(sym,val);
  220.  
  221.     /* return the result value */
  222.     return (val);
  223. }
  224.  
  225. /* xsetq - builtin function setq */
  226. NODE *xsetq(args)
  227.   NODE *args;
  228. {
  229.     NODE *oldstk,arg,sym,val;
  230.  
  231.     /* create a new stack frame */
  232.     oldstk = xlsave(&arg,&sym,&val,NULL);
  233.  
  234.     /* initialize */
  235.     arg.n_ptr = args;
  236.  
  237.     /* handle each pair of arguments */
  238.     while (arg.n_ptr) {
  239.     sym.n_ptr = xlmatch(SYM,&arg.n_ptr);
  240.     val.n_ptr = xlevarg(&arg.n_ptr);
  241.     assign(sym.n_ptr,val.n_ptr);
  242.     }
  243.  
  244.     /* restore the previous stack frame */
  245.     xlstack = oldstk;
  246.  
  247.     /* return the result value */
  248.     return (val.n_ptr);
  249. }
  250.  
  251. /* xdefun - builtin function 'defun' */
  252. NODE *xdefun(args)
  253.   NODE *args;
  254. {
  255.     return (defun(args,s_lambda));
  256. }
  257.  
  258. /* xdefmacro - builtin function 'defmacro' */
  259. NODE *xdefmacro(args)
  260.   NODE *args;
  261. {
  262.     return (defun(args,s_macro));
  263. }
  264.  
  265. /* defun - internal function definition routine */
  266. LOCAL NODE *defun(args,type)
  267.   NODE *args,*type;
  268. {
  269.     NODE *oldstk,sym,fargs,fun;
  270.  
  271.     /* create a new stack frame */
  272.     oldstk = xlsave(&sym,&fargs,&fun,NULL);
  273.  
  274.     /* get the function symbol and formal argument list */
  275.     sym.n_ptr = xlmatch(SYM,&args);
  276.     fargs.n_ptr = xlmatch(LIST,&args);
  277.  
  278.     /* create a new function definition */
  279.     fun.n_ptr = newnode(LIST);
  280.     rplaca(fun.n_ptr,type);
  281.     rplacd(fun.n_ptr,newnode(LIST));
  282.     rplaca(cdr(fun.n_ptr),fargs.n_ptr);
  283.     rplacd(cdr(fun.n_ptr),args);
  284.  
  285.     /* make the symbol point to a new function definition */
  286.     assign(sym.n_ptr,fun.n_ptr);
  287.  
  288.     /* restore the previous stack frame */
  289.     xlstack = oldstk;
  290.  
  291.     /* return the function symbol */
  292.     return (sym.n_ptr);
  293. }
  294.  
  295. /* xgensym - generate a symbol */
  296. NODE *xgensym(args)
  297.   NODE *args;
  298. {
  299.     char sym[STRMAX+1];
  300.     NODE *x;
  301.  
  302.     /* get the prefix or number */
  303.     if (args) {
  304.     x = xlarg(&args);
  305.     switch (ntype(x)) {
  306.     case STR:
  307.         strcpy(gsprefix,x->n_str);
  308.         break;
  309.     case INT:
  310.         gsnumber = x->n_int;
  311.         break;
  312.     default:
  313.         xlfail("bad argument type");
  314.     }
  315.     }
  316.     xllastarg(args);
  317.  
  318.     /* create the pname of the new symbol */
  319.     sprintf(sym,"%s%d",gsprefix,gsnumber++);
  320.  
  321.     /* make a symbol with this print name */
  322.     return (xlmakesym(sym,DYNAMIC));
  323. }
  324.  
  325. /* xmakesymbol - make a new uninterned symbol */
  326. NODE *xmakesymbol(args)
  327.   NODE *args;
  328. {
  329.     return (makesymbol(args,FALSE));
  330. }
  331.  
  332. /* xintern - make a new interned symbol */
  333. NODE *xintern(args)
  334.   NODE *args;
  335. {
  336.     return (makesymbol(args,TRUE));
  337. }
  338.  
  339. /* makesymbol - make a new symbol */
  340. LOCAL NODE *makesymbol(args,iflag)
  341.   NODE *args; int iflag;
  342. {
  343.     NODE *oldstk,pname,*val;
  344.     char *str;
  345.  
  346.     /* create a new stack frame */
  347.     oldstk = xlsave(&pname,NULL);
  348.  
  349.     /* get the print name of the symbol to intern */
  350.     pname.n_ptr = xlmatch(STR,&args);
  351.     xllastarg(args);
  352.  
  353.     /* make the symbol */
  354.     str = pname.n_ptr->n_str;
  355.     val = (iflag ? xlenter(str,DYNAMIC) : xlmakesym(str,DYNAMIC));
  356.  
  357.     /* restore the previous stack frame */
  358.     xlstack = oldstk;
  359.  
  360.     /* return the symbol */
  361.     return (val);
  362. }
  363.  
  364. /* xsymname - get the print name of a symbol */
  365. NODE *xsymname(args)
  366.   NODE *args;
  367. {
  368.     NODE *sym;
  369.  
  370.     /* get the symbol */
  371.     sym = xlmatch(SYM,&args);
  372.     xllastarg(args);
  373.  
  374.     /* return the print name */
  375.     return (car(sym->n_symplist));
  376. }
  377.  
  378. /* xsymvalue - get the print value of a symbol */
  379. NODE *xsymvalue(args)
  380.   NODE *args;
  381. {
  382.     NODE *sym;
  383.  
  384.     /* get the symbol */
  385.     sym = xlmatch(SYM,&args);
  386.     xllastarg(args);
  387.  
  388.     /* check for an unbound symbol */
  389.     while (sym->n_symvalue == s_unbound)
  390.     xlunbound(sym);
  391.  
  392.     /* return the value */
  393.     return (sym->n_symvalue);
  394. }
  395.  
  396. /* xsymplist - get the property list of a symbol */
  397. NODE *xsymplist(args)
  398.   NODE *args;
  399. {
  400.     NODE *sym;
  401.  
  402.     /* get the symbol */
  403.     sym = xlmatch(SYM,&args);
  404.     xllastarg(args);
  405.  
  406.     /* return the property list */
  407.     return (cdr(sym->n_symplist));
  408. }
  409.  
  410. /* xget - get the value of a property */
  411. NODE *xget(args)
  412.   NODE *args;
  413. {
  414.     NODE *sym,*prp;
  415.  
  416.     /* get the symbol and property */
  417.     sym = xlmatch(SYM,&args);
  418.     prp = xlmatch(SYM,&args);
  419.     xllastarg(args);
  420.  
  421.     /* retrieve the property value */
  422.     return (xlgetprop(sym,prp));
  423. }
  424.  
  425. /* xremprop - remove a property value from a property list */
  426. NODE *xremprop(args)
  427.   NODE *args;
  428. {
  429.     NODE *sym,*prp;
  430.  
  431.     /* get the symbol and property */
  432.     sym = xlmatch(SYM,&args);
  433.     prp = xlmatch(SYM,&args);
  434.     xllastarg(args);
  435.  
  436.     /* remove the property */
  437.     xlremprop(sym,prp);
  438.  
  439.     /* return nil */
  440.     return (NIL);
  441. }
  442. SHAR_EOF
  443. if test 8689 -ne "`wc -c < 'xlbfun.c'`"
  444. then
  445.     echo shar: error transmitting "'xlbfun.c'" '(should have been 8689 characters)'
  446. fi
  447. fi # end of overwriting check
  448. echo shar: extracting "'xlcont.c'" '(16880 characters)'
  449. if test -f 'xlcont.c'
  450. then
  451.     echo shar: will not over-write existing file "'xlcont.c'"
  452. else
  453. sed 's/^X//' << \SHAR_EOF > 'xlcont.c'
  454. /* xlcont - xlisp control built-in functions */
  455.  
  456. #include "xlisp.h"
  457.  
  458. /* external variables */
  459. extern NODE *xlstack,*xlenv,*xlnewenv,*xlvalue;
  460. extern NODE *s_unbound;
  461. extern NODE *s_evalhook,*s_applyhook;
  462. extern NODE *true;
  463.  
  464. /* external routines */
  465. extern NODE *xlxeval();
  466.  
  467. /* forward declarations */
  468. XFORWARD NODE *let();
  469. XFORWARD NODE *prog();
  470. XFORWARD NODE *progx();
  471. XFORWARD NODE *doloop();
  472.  
  473. /* xcond - built-in function 'cond' */
  474. NODE *xcond(args)
  475.   NODE *args;
  476. {
  477.     NODE *oldstk,arg,list,*val;
  478.  
  479.     /* create a new stack frame */
  480.     oldstk = xlsave(&arg,&list,NULL);
  481.  
  482.     /* initialize */
  483.     arg.n_ptr = args;
  484.  
  485.     /* initialize the return value */
  486.     val = NIL;
  487.  
  488.     /* find a predicate that is true */
  489.     while (arg.n_ptr) {
  490.  
  491.     /* get the next conditional */
  492.     list.n_ptr = xlmatch(LIST,&arg.n_ptr);
  493.  
  494.     /* evaluate the predicate part */
  495.     if (xlevarg(&list.n_ptr)) {
  496.  
  497.         /* evaluate each expression */
  498.         while (list.n_ptr)
  499.         val = xlevarg(&list.n_ptr);
  500.  
  501.         /* exit the loop */
  502.         break;
  503.     }
  504.     }
  505.  
  506.     /* restore the previous stack frame */
  507.     xlstack = oldstk;
  508.  
  509.     /* return the value */
  510.     return (val);
  511. }
  512.  
  513. /* xand - built-in function 'and' */
  514. NODE *xand(args)
  515.   NODE *args;
  516. {
  517.     NODE *oldstk,arg,*val;
  518.  
  519.     /* create a new stack frame */
  520.     oldstk = xlsave(&arg,NULL);
  521.  
  522.     /* initialize */
  523.     arg.n_ptr = args;
  524.     val = true;
  525.  
  526.     /* evaluate each argument */
  527.     while (arg.n_ptr)
  528.  
  529.     /* get the next argument */
  530.     if ((val = xlevarg(&arg.n_ptr)) == NIL)
  531.         break;
  532.  
  533.     /* restore the previous stack frame */
  534.     xlstack = oldstk;
  535.  
  536.     /* return the result value */
  537.     return (val);
  538. }
  539.  
  540. /* xor - built-in function 'or' */
  541. NODE *xor(args)
  542.   NODE *args;
  543. {
  544.     NODE *oldstk,arg,*val;
  545.  
  546.     /* create a new stack frame */
  547.     oldstk = xlsave(&arg,NULL);
  548.  
  549.     /* initialize */
  550.     arg.n_ptr = args;
  551.     val = NIL;
  552.  
  553.     /* evaluate each argument */
  554.     while (arg.n_ptr)
  555.     if ((val = xlevarg(&arg.n_ptr)))
  556.         break;
  557.  
  558.     /* restore the previous stack frame */
  559.     xlstack = oldstk;
  560.  
  561.     /* return the result value */
  562.     return (val);
  563. }
  564.  
  565. /* xif - built-in function 'if' */
  566. NODE *xif(args)
  567.   NODE *args;
  568. {
  569.     NODE *oldstk,testexpr,thenexpr,elseexpr,*val;
  570.  
  571.     /* create a new stack frame */
  572.     oldstk = xlsave(&testexpr,&thenexpr,&elseexpr,NULL);
  573.  
  574.     /* get the test expression, then clause and else clause */
  575.     testexpr.n_ptr = xlarg(&args);
  576.     thenexpr.n_ptr = xlarg(&args);
  577.     elseexpr.n_ptr = (args ? xlarg(&args) : NIL);
  578.     xllastarg(args);
  579.  
  580.     /* evaluate the appropriate clause */
  581.     val = xleval(xleval(testexpr.n_ptr) ? thenexpr.n_ptr : elseexpr.n_ptr);
  582.  
  583.     /* restore the previous stack frame */
  584.     xlstack = oldstk;
  585.  
  586.     /* return the last value */
  587.     return (val);
  588. }
  589.  
  590. /* xlet - built-in function 'let' */
  591. NODE *xlet(args)
  592.   NODE *args;
  593. {
  594.     return (let(args,TRUE));
  595. }
  596.  
  597. /* xletstar - built-in function 'let*' */
  598. NODE *xletstar(args)
  599.   NODE *args;
  600. {
  601.     return (let(args,FALSE));
  602. }
  603.  
  604. /* let - common let routine */
  605. LOCAL NODE *let(args,pflag)
  606.   NODE *args; int pflag;
  607. {
  608.     NODE *oldstk,*oldenv,*oldnewenv,arg,*val;
  609.  
  610.     /* create a new stack frame */
  611.     oldstk = xlsave(&arg,NULL);
  612.  
  613.     /* initialize */
  614.     arg.n_ptr = args;
  615.  
  616.     /* get the list of bindings and bind the symbols */
  617.     oldnewenv = xlnewenv; oldenv = xlnewenv = xlenv;
  618.     dobindings(xlmatch(LIST,&arg.n_ptr),pflag);
  619.  
  620.     /* execute the code */
  621.     for (val = NIL; arg.n_ptr; )
  622.     val = xlevarg(&arg.n_ptr);
  623.  
  624.     /* unbind the arguments */
  625.     xlunbind(oldenv); xlnewenv = oldnewenv;
  626.  
  627.     /* restore the previous stack frame */
  628.     xlstack = oldstk;
  629.  
  630.     /* return the result */
  631.     return (val);
  632. }
  633.  
  634. /* xprog - built-in function 'prog' */
  635. NODE *xprog(args)
  636.   NODE *args;
  637. {
  638.     return (prog(args,TRUE));
  639. }
  640.  
  641. /* xprogstar - built-in function 'prog*' */
  642. NODE *xprogstar(args)
  643.   NODE *args;
  644. {
  645.     return (prog(args,FALSE));
  646. }
  647.  
  648. /* prog - common prog routine */
  649. LOCAL NODE *prog(args,pflag)
  650.   NODE *args; int pflag;
  651. {
  652.     NODE *oldstk,*oldenv,*oldnewenv,arg,*val;
  653.  
  654.     /* create a new stack frame */
  655.     oldstk = xlsave(&arg,NULL);
  656.  
  657.     /* initialize */
  658.     arg.n_ptr = args;
  659.  
  660.     /* get the list of bindings and bind the symbols */
  661.     oldnewenv = xlnewenv; oldenv = xlnewenv = xlenv;
  662.     dobindings(xlmatch(LIST,&arg.n_ptr),pflag);
  663.  
  664.     /* execute the code */
  665.     tagblock(arg.n_ptr,&val);
  666.  
  667.     /* unbind the arguments */
  668.     xlunbind(oldenv); xlnewenv = oldnewenv;
  669.  
  670.     /* restore the previous stack frame */
  671.     xlstack = oldstk;
  672.  
  673.     /* return the result */
  674.     return (val);
  675. }
  676.  
  677. /* xgo - built-in function 'go' */
  678. NODE *xgo(args)
  679.   NODE *args;
  680. {
  681.     NODE *label;
  682.  
  683.     /* get the target label */
  684.     label = xlarg(&args);
  685.     xllastarg(args);
  686.  
  687.     /* transfer to the label */
  688.     xlgo(label);
  689. }
  690.  
  691. /* xreturn - built-in function 'return' */
  692. NODE *xreturn(args)
  693.   NODE *args;
  694. {
  695.     NODE *val;
  696.  
  697.     /* get the return value */
  698.     val = (args ? xlarg(&args) : NIL);
  699.     xllastarg(args);
  700.  
  701.     /* return from the inner most block */
  702.     xlreturn(val);
  703. }
  704.  
  705. /* xprog1 - built-in function 'prog1' */
  706. NODE *xprog1(args)
  707.   NODE *args;
  708. {
  709.     return (progx(args,1));
  710. }
  711.  
  712. /* xprog2 - built-in function 'prog2' */
  713. NODE *xprog2(args)
  714.   NODE *args;
  715. {
  716.     return (progx(args,2));
  717. }
  718.  
  719. /* progx - common progx code */
  720. LOCAL NODE *progx(args,n)
  721.   NODE *args; int n;
  722. {
  723.     NODE *oldstk,arg,val;
  724.  
  725.     /* create a new stack frame */
  726.     oldstk = xlsave(&arg,&val,NULL);
  727.  
  728.     /* initialize */
  729.     arg.n_ptr = args;
  730.  
  731.     /* evaluate the first n expressions */
  732.     while (n--)
  733.     val.n_ptr = xlevarg(&arg.n_ptr);
  734.  
  735.     /* evaluate each remaining argument */
  736.     while (arg.n_ptr)
  737.     xlevarg(&arg.n_ptr);
  738.  
  739.     /* restore the previous stack frame */
  740.     xlstack = oldstk;
  741.  
  742.     /* return the last test expression value */
  743.     return (val.n_ptr);
  744. }
  745.  
  746. /* xprogn - built-in function 'progn' */
  747. NODE *xprogn(args)
  748.   NODE *args;
  749. {
  750.     NODE *oldstk,arg,*val;
  751.  
  752.     /* create a new stack frame */
  753.     oldstk = xlsave(&arg,NULL);
  754.  
  755.     /* initialize */
  756.     arg.n_ptr = args;
  757.  
  758.     /* evaluate each remaining argument */
  759.     for (val = NIL; arg.n_ptr; )
  760.     val = xlevarg(&arg.n_ptr);
  761.  
  762.     /* restore the previous stack frame */
  763.     xlstack = oldstk;
  764.  
  765.     /* return the last test expression value */
  766.     return (val);
  767. }
  768.  
  769. /* xdo - built-in function 'do' */
  770. NODE *xdo(args)
  771.   NODE *args;
  772. {
  773.     return (doloop(args,TRUE));
  774. }
  775.  
  776. /* xdostar - built-in function 'do*' */
  777. NODE *xdostar(args)
  778.   NODE *args;
  779. {
  780.     return (doloop(args,FALSE));
  781. }
  782.  
  783. /* doloop - common do routine */
  784. LOCAL NODE *doloop(args,pflag)
  785.   NODE *args; int pflag;
  786. {
  787.     NODE *oldstk,*oldenv,*oldnewenv,arg,blist,clist,test,*rval;
  788.     int rbreak;
  789.  
  790.     /* create a new stack frame */
  791.     oldstk = xlsave(&arg,&blist,&clist,&test,NULL);
  792.  
  793.     /* initialize */
  794.     arg.n_ptr = args;
  795.  
  796.     /* get the list of bindings and bind the symbols */
  797.     blist.n_ptr = xlmatch(LIST,&arg.n_ptr);
  798.     oldnewenv = xlnewenv; oldenv = xlnewenv = xlenv;
  799.     dobindings(blist.n_ptr,pflag);
  800.  
  801.     /* get the exit test and result forms */
  802.     clist.n_ptr = xlmatch(LIST,&arg.n_ptr);
  803.     test.n_ptr = xlarg(&clist.n_ptr);
  804.  
  805.     /* execute the loop as long as the test is false */
  806.     rbreak = FALSE;
  807.     while (xleval(test.n_ptr) == NIL) {
  808.  
  809.     /* execute the body of the loop */
  810.     if (tagblock(arg.n_ptr,&rval)) {
  811.         rbreak = TRUE;
  812.         break;
  813.     }
  814.  
  815.     /* update the looping variables */
  816.     doupdates(blist.n_ptr,pflag);
  817.     }
  818.  
  819.     /* evaluate the result expression */
  820.     if (!rbreak)
  821.     for (rval = NIL; consp(clist.n_ptr); )
  822.         rval = xlevarg(&clist.n_ptr);
  823.  
  824.     /* unbind the arguments */
  825.     xlunbind(oldenv); xlnewenv = oldnewenv;
  826.  
  827.     /* restore the previous stack frame */
  828.     xlstack = oldstk;
  829.  
  830.     /* return the result */
  831.     return (rval);
  832. }
  833.  
  834. /* xdolist - built-in function 'dolist' */
  835. NODE *xdolist(args)
  836.   NODE *args;
  837. {
  838.     NODE *oldstk,*oldenv,arg,clist,sym,list,val,*rval;
  839.     int rbreak;
  840.  
  841.     /* create a new stack frame */
  842.     oldstk = xlsave(&arg,&clist,&sym,&list,&val,NULL);
  843.  
  844.     /* initialize */
  845.     arg.n_ptr = args;
  846.  
  847.     /* get the control list (sym list result-expr) */
  848.     clist.n_ptr = xlmatch(LIST,&arg.n_ptr);
  849.     sym.n_ptr = xlmatch(SYM,&clist.n_ptr);
  850.     list.n_ptr = xlevmatch(LIST,&clist.n_ptr);
  851.     val.n_ptr = (clist.n_ptr ? xlarg(&clist.n_ptr) : NIL);
  852.  
  853.     /* initialize the local environment */
  854.     oldenv = xlenv;
  855.     xlsbind(sym.n_ptr,NIL);
  856.  
  857.     /* loop through the list */
  858.     rbreak = FALSE;
  859.     for (; consp(list.n_ptr); list.n_ptr = cdr(list.n_ptr)) {
  860.  
  861.     /* bind the symbol to the next list element */
  862.     sym.n_ptr->n_symvalue = car(list.n_ptr);
  863.  
  864.     /* execute the loop body */
  865.     if (tagblock(arg.n_ptr,&rval)) {
  866.         rbreak = TRUE;
  867.         break;
  868.     }
  869.     }
  870.  
  871.     /* evaluate the result expression */
  872.     if (!rbreak) {
  873.     sym.n_ptr->n_symvalue = NIL;
  874.     rval = xleval(val.n_ptr);
  875.     }
  876.  
  877.     /* unbind the arguments */
  878.     xlunbind(oldenv);
  879.  
  880.     /* restore the previous stack frame */
  881.     xlstack = oldstk;
  882.  
  883.     /* return the result */
  884.     return (rval);
  885. }
  886.  
  887. /* xdotimes - built-in function 'dotimes' */
  888. NODE *xdotimes(args)
  889.   NODE *args;
  890. {
  891.     NODE *oldstk,*oldenv,arg,clist,sym,val,*rval;
  892.     int rbreak,cnt,i;
  893.  
  894.     /* create a new stack frame */
  895.     oldstk = xlsave(&arg,&clist,&sym,&val,NULL);
  896.  
  897.     /* initialize */
  898.     arg.n_ptr = args;
  899.  
  900.     /* get the control list (sym list result-expr) */
  901.     clist.n_ptr = xlmatch(LIST,&arg.n_ptr);
  902.     sym.n_ptr = xlmatch(SYM,&clist.n_ptr);
  903.     cnt = xlevmatch(INT,&clist.n_ptr)->n_int;
  904.     val.n_ptr = (clist.n_ptr ? xlarg(&clist.n_ptr) : NIL);
  905.  
  906.     /* initialize the local environment */
  907.     oldenv = xlenv;
  908.     xlsbind(sym.n_ptr,NIL);
  909.  
  910.     /* loop through for each value from zero to cnt-1 */
  911.     rbreak = FALSE;
  912.     for (i = 0; i < cnt; i++) {
  913.  
  914.     /* bind the symbol to the next list element */
  915.     sym.n_ptr->n_symvalue = newnode(INT);
  916.     sym.n_ptr->n_symvalue->n_int = i;
  917.  
  918.     /* execute the loop body */
  919.     if (tagblock(arg.n_ptr,&rval)) {
  920.         rbreak = TRUE;
  921.         break;
  922.     }
  923.     }
  924.  
  925.     /* evaluate the result expression */
  926.     if (!rbreak) {
  927.     sym.n_ptr->n_symvalue = newnode(INT);
  928.     sym.n_ptr->n_symvalue->n_int = cnt;
  929.     rval = xleval(val.n_ptr);
  930.     }
  931.  
  932.     /* unbind the arguments */
  933.     xlunbind(oldenv);
  934.  
  935.     /* restore the previous stack frame */
  936.     xlstack = oldstk;
  937.  
  938.     /* return the result */
  939.     return (rval);
  940. }
  941.  
  942. /* xcatch - built-in function 'catch' */
  943. NODE *xcatch(args)
  944.   NODE *args;
  945. {
  946.     NODE *oldstk,tag,arg,*val;
  947.     CONTEXT cntxt;
  948.  
  949.     /* create a new stack frame */
  950.     oldstk = xlsave(&tag,&arg,NULL);
  951.  
  952.     /* initialize */
  953.     tag.n_ptr = xlevarg(&args);
  954.     arg.n_ptr = args;
  955.     val = NIL;
  956.  
  957.     /* establish an execution context */
  958.     xlbegin(&cntxt,CF_THROW,tag.n_ptr);
  959.  
  960.     /* check for 'throw' */
  961.     if (setjmp(cntxt.c_jmpbuf))
  962.     val = xlvalue;
  963.  
  964.     /* otherwise, evaluate the remainder of the arguments */
  965.     else {
  966.     while (arg.n_ptr)
  967.         val = xlevarg(&arg.n_ptr);
  968.     }
  969.     xlend(&cntxt);
  970.  
  971.     /* restore the previous stack frame */
  972.     xlstack = oldstk;
  973.  
  974.     /* return the result */
  975.     return (val);
  976. }
  977.  
  978. /* xthrow - built-in function 'throw' */
  979. NODE *xthrow(args)
  980.   NODE *args;
  981. {
  982.     NODE *tag,*val;
  983.  
  984.     /* get the tag and value */
  985.     tag = xlarg(&args);
  986.     val = (args ? xlarg(&args) : NIL);
  987.     xllastarg(args);
  988.  
  989.     /* throw the tag */
  990.     xlthrow(tag,val);
  991. }
  992.  
  993. /* xerror - built-in function 'error' */
  994. NODE *xerror(args)
  995.   NODE *args;
  996. {
  997.     char *emsg; NODE *arg;
  998.  
  999.     /* get the error message and the argument */
  1000.     emsg = xlmatch(STR,&args)->n_str;
  1001.     arg = (args ? xlarg(&args) : s_unbound);
  1002.     xllastarg(args);
  1003.  
  1004.     /* signal the error */
  1005.     xlerror(emsg,arg);
  1006. }
  1007.  
  1008. /* xcerror - built-in function 'cerror' */
  1009. NODE *xcerror(args)
  1010.   NODE *args;
  1011. {
  1012.     char *cmsg,*emsg; NODE *arg;
  1013.  
  1014.     /* get the correction message, the error message, and the argument */
  1015.     cmsg = xlmatch(STR,&args)->n_str;
  1016.     emsg = xlmatch(STR,&args)->n_str;
  1017.     arg = (args ? xlarg(&args) : s_unbound);
  1018.     xllastarg(args);
  1019.  
  1020.     /* signal the error */
  1021.     xlcerror(cmsg,emsg,arg);
  1022.  
  1023.     /* return nil */
  1024.     return (NIL);
  1025. }
  1026.  
  1027. /* xbreak - built-in function 'break' */
  1028. NODE *xbreak(args)
  1029.   NODE *args;
  1030. {
  1031.     char *emsg; NODE *arg;
  1032.  
  1033.     /* get the error message */
  1034.     emsg = (args ? xlmatch(STR,&args)->n_str : "**BREAK**");
  1035.     arg = (args ? xlarg(&args) : s_unbound);
  1036.     xllastarg(args);
  1037.  
  1038.     /* enter the break loop */
  1039.     xlbreak(emsg,arg);
  1040.  
  1041.     /* return nil */
  1042.     return (NIL);
  1043. }
  1044.  
  1045. /* xerrset - built-in function 'errset' */
  1046. NODE *xerrset(args)
  1047.   NODE *args;
  1048. {
  1049.     NODE *oldstk,expr,flag,*val;
  1050.     CONTEXT cntxt;
  1051.  
  1052.     /* create a new stack frame */
  1053.     oldstk = xlsave(&expr,&flag,NULL);
  1054.  
  1055.     /* get the expression and the print flag */
  1056.     expr.n_ptr = xlarg(&args);
  1057.     flag.n_ptr = (args ? xlarg(&args) : true);
  1058.     xllastarg(args);
  1059.  
  1060.     /* establish an execution context */
  1061.     xlbegin(&cntxt,CF_ERROR,flag.n_ptr);
  1062.  
  1063.     /* check for error */
  1064.     if (setjmp(cntxt.c_jmpbuf))
  1065.     val = NIL;
  1066.  
  1067.     /* otherwise, evaluate the expression */
  1068.     else {
  1069.     expr.n_ptr = xleval(expr.n_ptr);
  1070.     val = newnode(LIST);
  1071.     rplaca(val,expr.n_ptr);
  1072.     }
  1073.     xlend(&cntxt);
  1074.  
  1075.     /* restore the previous stack frame */
  1076.     xlstack = oldstk;
  1077.  
  1078.     /* return the result */
  1079.     return (val);
  1080. }
  1081.  
  1082. /* xevalhook - eval hook function */
  1083. NODE *xevalhook(args)
  1084.   NODE *args;
  1085. {
  1086.     NODE *oldstk,*oldenv,expr,ehook,ahook,*val;
  1087.  
  1088.     /* create a new stack frame */
  1089.     oldstk = xlsave(&expr,&ehook,&ahook,NULL);
  1090.  
  1091.     /* get the expression and the hook functions */
  1092.     expr.n_ptr = xlarg(&args);
  1093.     ehook.n_ptr = xlarg(&args);
  1094.     ahook.n_ptr = xlarg(&args);
  1095.     xllastarg(args);
  1096.  
  1097.     /* bind *evalhook* and *applyhook* to the hook functions */
  1098.     oldenv = xlenv;
  1099.     xlsbind(s_evalhook,ehook.n_ptr);
  1100.     xlsbind(s_applyhook,ahook.n_ptr);
  1101.  
  1102.     /* evaluate the expression (bypassing *evalhook*) */
  1103.     val = xlxeval(expr.n_ptr);
  1104.  
  1105.     /* unbind the hook variables */
  1106.     xlunbind(oldenv);
  1107.  
  1108.     /* restore the previous stack frame */
  1109.     xlstack = oldstk;
  1110.  
  1111.     /* return the result */
  1112.     return (val);
  1113. }
  1114.  
  1115. /* dobindings - handle bindings for let/let*, prog/prog*, do/do* */
  1116. LOCAL dobindings(blist,pflag)
  1117.   NODE *blist; int pflag;
  1118. {
  1119.     NODE *oldstk,list,bnd,sym,val;
  1120.  
  1121.     /* create a new stack frame */
  1122.     oldstk = xlsave(&list,&bnd,&sym,&val,NULL);
  1123.  
  1124.    /* bind each symbol in the list of bindings */
  1125.     for (list.n_ptr = blist; consp(list.n_ptr); list.n_ptr = cdr(list.n_ptr)) {
  1126.  
  1127.     /* get the next binding */
  1128.     bnd.n_ptr = car(list.n_ptr);
  1129.  
  1130.     /* handle a symbol */
  1131.     if (symbolp(bnd.n_ptr)) {
  1132.         sym.n_ptr = bnd.n_ptr;
  1133.         val.n_ptr = NIL;
  1134.     }
  1135.  
  1136.     /* handle a list of the form (symbol expr) */
  1137.     else if (consp(bnd.n_ptr)) {
  1138.         sym.n_ptr = xlmatch(SYM,&bnd.n_ptr);
  1139.         val.n_ptr = xlevarg(&bnd.n_ptr);
  1140.     }
  1141.     else
  1142.         xlfail("bad binding");
  1143.  
  1144.     /* bind the value to the symbol */
  1145.     if (pflag)
  1146.         xlbind(sym.n_ptr,val.n_ptr);
  1147.     else
  1148.         xlsbind(sym.n_ptr,val.n_ptr);
  1149.     }
  1150.  
  1151.     /* fix the bindings on a parallel let */
  1152.     if (pflag)
  1153.     xlfixbindings();
  1154.  
  1155.     /* restore the previous stack frame */
  1156.     xlstack = oldstk;
  1157. }
  1158.  
  1159. /* doupdates - handle updates for do/do* */
  1160. doupdates(blist,pflag)
  1161.   NODE *blist; int pflag;
  1162. {
  1163.     NODE *oldstk,*oldenv,*oldnewenv,list,bnd,sym,val;
  1164.  
  1165.     /* create a new stack frame */
  1166.     oldstk = xlsave(&list,&bnd,&sym,&val,NULL);
  1167.  
  1168.     /* initialize the local environment */
  1169.     if (pflag) {
  1170.     oldenv = xlenv; oldnewenv = xlnewenv;
  1171.     }
  1172.  
  1173.     /* bind each symbol in the list of bindings */
  1174.     for (list.n_ptr = blist; consp(list.n_ptr); list.n_ptr = cdr(list.n_ptr)) {
  1175.  
  1176.     /* get the next binding */
  1177.     bnd.n_ptr = car(list.n_ptr);
  1178.  
  1179.     /* handle a list of the form (symbol expr) */
  1180.     if (consp(bnd.n_ptr)) {
  1181.         sym.n_ptr = xlmatch(SYM,&bnd.n_ptr);
  1182.         bnd.n_ptr = cdr(bnd.n_ptr);
  1183.         if (bnd.n_ptr) {
  1184.         val.n_ptr = xlevarg(&bnd.n_ptr);
  1185.         if (pflag)
  1186.             xlbind(sym.n_ptr,val.n_ptr);
  1187.         else
  1188.             sym.n_ptr->n_symvalue = val.n_ptr;
  1189.         }
  1190.     }
  1191.     }
  1192.  
  1193.     /* fix the bindings on a parallel let */
  1194.     if (pflag) {
  1195.     xlfixbindings();
  1196.     xlenv = oldenv; xlnewenv = oldnewenv;
  1197.     }
  1198.  
  1199.     /* restore the previous stack frame */
  1200.     xlstack = oldstk;
  1201. }
  1202.  
  1203. /* tagblock - execute code within a block and tagbody */
  1204. int tagblock(code,pval)
  1205.   NODE *code,**pval;
  1206. {
  1207.     NODE *oldstk,arg;
  1208.     CONTEXT cntxt;
  1209.     int type,sts;
  1210.  
  1211.     /* create a new stack frame */
  1212.     oldstk = xlsave(&arg,NULL);
  1213.  
  1214.     /* initialize */
  1215.     arg.n_ptr = code;
  1216.  
  1217.     /* establish an execution context */
  1218.     xlbegin(&cntxt,CF_GO|CF_RETURN,arg.n_ptr);
  1219.  
  1220.     /* check for a 'return' */
  1221.     if ((type = setjmp(cntxt.c_jmpbuf)) == CF_RETURN) {
  1222.     *pval = xlvalue;
  1223.     sts = TRUE;
  1224.     }
  1225.  
  1226.     /* otherwise, enter the body */
  1227.     else {
  1228.  
  1229.     /* check for a 'go' */
  1230.     if (type == CF_GO)
  1231.         arg.n_ptr = xlvalue;
  1232.  
  1233.     /* evaluate each expression in the body */
  1234.     while (consp(arg.n_ptr))
  1235.         if (consp(car(arg.n_ptr)))
  1236.         xlevarg(&arg.n_ptr);
  1237.         else
  1238.         arg.n_ptr = cdr(arg.n_ptr);
  1239.     
  1240.     /* indicate that we fell through the bottom of the tagbody */
  1241.     *pval = NIL;
  1242.     sts = FALSE;
  1243.     }
  1244.     xlend(&cntxt);
  1245.  
  1246.     /* restore the previous stack frame */
  1247.     xlstack = oldstk;
  1248.  
  1249.     /* return status */
  1250.     return (sts);
  1251. }
  1252. SHAR_EOF
  1253. if test 16880 -ne "`wc -c < 'xlcont.c'`"
  1254. then
  1255.     echo shar: error transmitting "'xlcont.c'" '(should have been 16880 characters)'
  1256. fi
  1257. fi # end of overwriting check
  1258. echo shar: extracting "'xllist.c'" '(17752 characters)'
  1259. if test -f 'xllist.c'
  1260. then
  1261.     echo shar: will not over-write existing file "'xllist.c'"
  1262. else
  1263. sed 's/^X//' << \SHAR_EOF > 'xllist.c'
  1264. /* xllist - xlisp built-in list functions */
  1265.  
  1266. #include "xlisp.h"
  1267.  
  1268. #ifdef MEGAMAX
  1269. overlay "overflow"
  1270. #endif
  1271.  
  1272. /* external variables */
  1273. extern NODE *xlstack;
  1274. extern NODE *s_unbound;
  1275. extern NODE *true;
  1276.  
  1277. /* external routines */
  1278. extern int eq(),eql(),equal();
  1279.  
  1280. /* forward declarations */
  1281. XFORWARD NODE *cxr();
  1282. XFORWARD NODE *nth(),*assoc();
  1283. XFORWARD NODE *subst(),*sublis(),*map();
  1284. XFORWARD NODE *cequal();
  1285.  
  1286. /* xcar - return the car of a list */
  1287. NODE *xcar(args)
  1288.   NODE *args;
  1289. {
  1290.     return (cxr(args,"a"));
  1291. }
  1292.  
  1293. /* xcdr - return the cdr of a list */
  1294. NODE *xcdr(args)
  1295.   NODE *args;
  1296. {
  1297.     return (cxr(args,"d"));
  1298. }
  1299.  
  1300. /* xcaar - return the caar of a list */
  1301. NODE *xcaar(args)
  1302.   NODE *args;
  1303. {
  1304.     return (cxr(args,"aa"));
  1305. }
  1306.  
  1307. /* xcadr - return the cadr of a list */
  1308. NODE *xcadr(args)
  1309.   NODE *args;
  1310. {
  1311.     return (cxr(args,"da"));
  1312. }
  1313.  
  1314. /* xcdar - return the cdar of a list */
  1315. NODE *xcdar(args)
  1316.   NODE *args;
  1317. {
  1318.     return (cxr(args,"ad"));
  1319. }
  1320.  
  1321. /* xcddr - return the cddr of a list */
  1322. NODE *xcddr(args)
  1323.   NODE *args;
  1324. {
  1325.     return (cxr(args,"dd"));
  1326. }
  1327.  
  1328. /* cxr - common car/cdr routine */
  1329. LOCAL NODE *cxr(args,adstr)
  1330.   NODE *args; char *adstr;
  1331. {
  1332.     NODE *list;
  1333.  
  1334.     /* get the list */
  1335.     list = xlmatch(LIST,&args);
  1336.     xllastarg(args);
  1337.  
  1338.     /* perform the car/cdr operations */
  1339.     while (*adstr && consp(list))
  1340.     list = (*adstr++ == 'a' ? car(list) : cdr(list));
  1341.  
  1342.     /* make sure the operation succeeded */
  1343.     if (*adstr && list)
  1344.     xlfail("bad argument");
  1345.  
  1346.     /* return the result */
  1347.     return (list);
  1348. }
  1349.  
  1350. /* xcons - construct a new list cell */
  1351. NODE *xcons(args)
  1352.   NODE *args;
  1353. {
  1354.     NODE *arg1,*arg2,*val;
  1355.  
  1356.     /* get the two arguments */
  1357.     arg1 = xlarg(&args);
  1358.     arg2 = xlarg(&args);
  1359.     xllastarg(args);
  1360.  
  1361.     /* construct a new list element */
  1362.     val = newnode(LIST);
  1363.     rplaca(val,arg1);
  1364.     rplacd(val,arg2);
  1365.  
  1366.     /* return the list */
  1367.     return (val);
  1368. }
  1369.  
  1370. /* xlist - built a list of the arguments */
  1371. NODE *xlist(args)
  1372.   NODE *args;
  1373. {
  1374.     NODE *oldstk,arg,list,val,*last,*lptr;
  1375.  
  1376.     /* create a new stack frame */
  1377.     oldstk = xlsave(&arg,&list,&val,NULL);
  1378.  
  1379.     /* initialize */
  1380.     arg.n_ptr = args;
  1381.  
  1382.     /* evaluate and append each argument */
  1383.     for (last = NIL; arg.n_ptr != NIL; last = lptr) {
  1384.  
  1385.     /* evaluate the next argument */
  1386.     val.n_ptr = xlarg(&arg.n_ptr);
  1387.  
  1388.     /* append this argument to the end of the list */
  1389.     lptr = newnode(LIST);
  1390.     if (last == NIL)
  1391.         list.n_ptr = lptr;
  1392.     else
  1393.         rplacd(last,lptr);
  1394.     rplaca(lptr,val.n_ptr);
  1395.     }
  1396.  
  1397.     /* restore the previous stack frame */
  1398.     xlstack = oldstk;
  1399.  
  1400.     /* return the list */
  1401.     return (list.n_ptr);
  1402. }
  1403.  
  1404. /* xappend - built-in function append */
  1405. NODE *xappend(args)
  1406.   NODE *args;
  1407. {
  1408.     NODE *oldstk,arg,list,last,val,*lptr;
  1409.  
  1410.     /* create a new stack frame */
  1411.     oldstk = xlsave(&arg,&list,&last,&val,NULL);
  1412.  
  1413.     /* initialize */
  1414.     arg.n_ptr = args;
  1415.  
  1416.     /* evaluate and append each argument */
  1417.     while (arg.n_ptr) {
  1418.  
  1419.     /* evaluate the next argument */
  1420.     list.n_ptr = xlmatch(LIST,&arg.n_ptr);
  1421.  
  1422.     /* append each element of this list to the result list */
  1423.     while (consp(list.n_ptr)) {
  1424.  
  1425.         /* append this element */
  1426.         lptr = newnode(LIST);
  1427.         if (last.n_ptr == NIL)
  1428.         val.n_ptr = lptr;
  1429.         else
  1430.         rplacd(last.n_ptr,lptr);
  1431.         rplaca(lptr,car(list.n_ptr));
  1432.  
  1433.         /* save the new last element */
  1434.         last.n_ptr = lptr;
  1435.  
  1436.         /* move to the next element */
  1437.         list.n_ptr = cdr(list.n_ptr);
  1438.     }
  1439.     }
  1440.  
  1441.     /* restore previous stack frame */
  1442.     xlstack = oldstk;
  1443.  
  1444.     /* return the list */
  1445.     return (val.n_ptr);
  1446. }
  1447.  
  1448. /* xreverse - built-in function reverse */
  1449. NODE *xreverse(args)
  1450.   NODE *args;
  1451. {
  1452.     NODE *oldstk,list,val,*lptr;
  1453.  
  1454.     /* create a new stack frame */
  1455.     oldstk = xlsave(&list,&val,NULL);
  1456.  
  1457.     /* get the list to reverse */
  1458.     list.n_ptr = xlmatch(LIST,&args);
  1459.     xllastarg(args);
  1460.  
  1461.     /* append each element of this list to the result list */
  1462.     while (consp(list.n_ptr)) {
  1463.  
  1464.     /* append this element */
  1465.     lptr = newnode(LIST);
  1466.     rplaca(lptr,car(list.n_ptr));
  1467.     rplacd(lptr,val.n_ptr);
  1468.     val.n_ptr = lptr;
  1469.  
  1470.     /* move to the next element */
  1471.     list.n_ptr = cdr(list.n_ptr);
  1472.     }
  1473.  
  1474.     /* restore previous stack frame */
  1475.     xlstack = oldstk;
  1476.  
  1477.     /* return the list */
  1478.     return (val.n_ptr);
  1479. }
  1480.  
  1481. /* xlast - return the last cons of a list */
  1482. NODE *xlast(args)
  1483.   NODE *args;
  1484. {
  1485.     NODE *list;
  1486.  
  1487.     /* get the list */
  1488.     list = xlmatch(LIST,&args);
  1489.     xllastarg(args);
  1490.  
  1491.     /* find the last cons */
  1492.     while (consp(list) && cdr(list))
  1493.     list = cdr(list);
  1494.  
  1495.     /* return the last element */
  1496.     return (list);
  1497. }
  1498.  
  1499. /* xmember - built-in function 'member' */
  1500. NODE *xmember(args)
  1501.   NODE *args;
  1502. {
  1503.     NODE *oldstk,x,list,fcn,*val;
  1504.     int tresult;
  1505.  
  1506.     /* create a new stack frame */
  1507.     oldstk = xlsave(&x,&list,&fcn,NULL);
  1508.  
  1509.     /* get the expression to look for and the list */
  1510.     x.n_ptr = xlarg(&args);
  1511.     list.n_ptr = xlmatch(LIST,&args);
  1512.     xltest(&fcn.n_ptr,&tresult,&args);
  1513.     xllastarg(args);
  1514.  
  1515.     /* look for the expression */
  1516.     for (val = NIL; consp(list.n_ptr); list.n_ptr = cdr(list.n_ptr))
  1517.     if (dotest(x.n_ptr,car(list.n_ptr),fcn.n_ptr) == tresult) {
  1518.         val = list.n_ptr;
  1519.         break;
  1520.     }
  1521.  
  1522.     /* restore the previous stack frame */
  1523.     xlstack = oldstk;
  1524.  
  1525.     /* return the result */
  1526.     return (val);
  1527. }
  1528.  
  1529. /* xassoc - built-in function 'assoc' */
  1530. NODE *xassoc(args)
  1531.   NODE *args;
  1532. {
  1533.     NODE *oldstk,x,alist,fcn,*pair,*val;
  1534.     int tresult;
  1535.  
  1536.     /* create a new stack frame */
  1537.     oldstk = xlsave(&x,&alist,&fcn,NULL);
  1538.  
  1539.     /* get the expression to look for and the association list */
  1540.     x.n_ptr = xlarg(&args);
  1541.     alist.n_ptr = xlmatch(LIST,&args);
  1542.     xltest(&fcn.n_ptr,&tresult,&args);
  1543.     xllastarg(args);
  1544.  
  1545.     /* look for the expression */
  1546.     for (val = NIL; consp(alist.n_ptr); alist.n_ptr = cdr(alist.n_ptr))
  1547.     if ((pair = car(alist.n_ptr)) && consp(pair))
  1548.         if (dotest(x.n_ptr,car(pair),fcn.n_ptr) == tresult) {
  1549.         val = pair;
  1550.         break;
  1551.         }
  1552.  
  1553.     /* restore the previous stack frame */
  1554.     xlstack = oldstk;
  1555.  
  1556.     /* return the result */
  1557.     return (val);
  1558. }
  1559.  
  1560. /* xsubst - substitute one expression for another */
  1561. NODE *xsubst(args)
  1562.   NODE *args;
  1563. {
  1564.     NODE *oldstk,to,from,expr,fcn,*val;
  1565.     int tresult;
  1566.  
  1567.     /* create a new stack frame */
  1568.     oldstk = xlsave(&to,&from,&expr,&fcn,NULL);
  1569.  
  1570.     /* get the to value, the from value and the expression */
  1571.     to.n_ptr = xlarg(&args);
  1572.     from.n_ptr = xlarg(&args);
  1573.     expr.n_ptr = xlarg(&args);
  1574.     xltest(&fcn.n_ptr,&tresult,&args);
  1575.     xllastarg(args);
  1576.  
  1577.     /* do the substitution */
  1578.     val = subst(to.n_ptr,from.n_ptr,expr.n_ptr,fcn.n_ptr,tresult);
  1579.  
  1580.     /* restore the previous stack frame */
  1581.     xlstack = oldstk;
  1582.  
  1583.     /* return the result */
  1584.     return (val);
  1585. }
  1586.  
  1587. /* subst - substitute one expression for another */
  1588. LOCAL NODE *subst(to,from,expr,fcn,tresult)
  1589.   NODE *to,*from,*expr,*fcn; int tresult;
  1590. {
  1591.     NODE *oldstk,carval,cdrval,*val;
  1592.  
  1593.     if (dotest(expr,from,fcn) == tresult)
  1594.     val = to;
  1595.     else if (consp(expr)) {
  1596.     oldstk = xlsave(&carval,&cdrval,NULL);
  1597.     carval.n_ptr = subst(to,from,car(expr),fcn,tresult);
  1598.     cdrval.n_ptr = subst(to,from,cdr(expr),fcn,tresult);
  1599.     val = newnode(LIST);
  1600.     rplaca(val,carval.n_ptr);
  1601.     rplacd(val,cdrval.n_ptr);
  1602.     xlstack = oldstk;
  1603.     }
  1604.     else
  1605.     val = expr;
  1606.     return (val);
  1607. }
  1608.  
  1609. /* xsublis - substitute using an association list */
  1610. NODE *xsublis(args)
  1611.   NODE *args;
  1612. {
  1613.     NODE *oldstk,alist,expr,fcn,*val;
  1614.     int tresult;
  1615.  
  1616.     /* create a new stack frame */
  1617.     oldstk = xlsave(&alist,&expr,&fcn,NULL);
  1618.  
  1619.     /* get the assocation list and the expression */
  1620.     alist.n_ptr = xlmatch(LIST,&args);
  1621.     expr.n_ptr = xlarg(&args);
  1622.     xltest(&fcn.n_ptr,&tresult,&args);
  1623.     xllastarg(args);
  1624.  
  1625.     /* do the substitution */
  1626.     val = sublis(alist.n_ptr,expr.n_ptr,fcn.n_ptr,tresult);
  1627.  
  1628.     /* restore the previous stack frame */
  1629.     xlstack = oldstk;
  1630.  
  1631.     /* return the result */
  1632.     return (val);
  1633. }
  1634.  
  1635. /* sublis - substitute using an association list */
  1636. LOCAL NODE *sublis(alist,expr,fcn,tresult)
  1637.   NODE *alist,*expr,*fcn; int tresult;
  1638. {
  1639.     NODE *oldstk,carval,cdrval,*val;
  1640.  
  1641.     if (val = assoc(expr,alist,fcn,tresult))
  1642.     val = cdr(val);
  1643.     else if (consp(expr)) {
  1644.     oldstk = xlsave(&carval,&cdrval,NULL);
  1645.     carval.n_ptr = sublis(alist,car(expr),fcn,tresult);
  1646.     cdrval.n_ptr = sublis(alist,cdr(expr),fcn,tresult);
  1647.     val = newnode(LIST);
  1648.     rplaca(val,carval.n_ptr);
  1649.     rplacd(val,cdrval.n_ptr);
  1650.     xlstack = oldstk;
  1651.     }
  1652.     else
  1653.     val = expr;
  1654.     return (val);
  1655. }
  1656.  
  1657. /* assoc - find a pair in an association list */
  1658. LOCAL NODE *assoc(expr,alist,fcn,tresult)
  1659.   NODE *expr,*alist,*fcn; int tresult;
  1660. {
  1661.     NODE *pair;
  1662.  
  1663.     for (; consp(alist); alist = cdr(alist))
  1664.     if ((pair = car(alist)) && consp(pair))
  1665.         if (dotest(expr,car(pair),fcn) == tresult)
  1666.         return (pair);
  1667.     return (NIL);
  1668. }
  1669.  
  1670. /* xremove - built-in function 'remove' */
  1671. NODE *xremove(args)
  1672.   NODE *args;
  1673. {
  1674.     NODE *oldstk,x,list,fcn,val,*p,*last;
  1675.     int tresult;
  1676.  
  1677.     /* create a new stack frame */
  1678.     oldstk = xlsave(&x,&list,&fcn,&val,NULL);
  1679.  
  1680.     /* get the expression to remove and the list */
  1681.     x.n_ptr = xlarg(&args);
  1682.     list.n_ptr = xlmatch(LIST,&args);
  1683.     xltest(&fcn.n_ptr,&tresult,&args);
  1684.     xllastarg(args);
  1685.  
  1686.     /* remove matches */
  1687.     while (consp(list.n_ptr)) {
  1688.  
  1689.     /* check to see if this element should be deleted */
  1690.     if (dotest(x.n_ptr,car(list.n_ptr),fcn.n_ptr) != tresult) {
  1691.         p = newnode(LIST);
  1692.         rplaca(p,car(list.n_ptr));
  1693.         if (val.n_ptr) rplacd(last,p);
  1694.         else val.n_ptr = p;
  1695.         last = p;
  1696.     }
  1697.  
  1698.     /* move to the next element */
  1699.     list.n_ptr = cdr(list.n_ptr);
  1700.     }
  1701.  
  1702.     /* restore the previous stack frame */
  1703.     xlstack = oldstk;
  1704.  
  1705.     /* return the updated list */
  1706.     return (val.n_ptr);
  1707. }
  1708.  
  1709. /* dotest - call a test function */
  1710. int dotest(arg1,arg2,fcn)
  1711.   NODE *arg1,*arg2,*fcn;
  1712. {
  1713.     NODE *oldstk,args,*val;
  1714.  
  1715.     /* create a new stack frame */
  1716.     oldstk = xlsave(&args,NULL);
  1717.  
  1718.     /* build an argument list */
  1719.     args.n_ptr = newnode(LIST);
  1720.     rplaca(args.n_ptr,arg1);
  1721.     rplacd(args.n_ptr,newnode(LIST));
  1722.     rplaca(cdr(args.n_ptr),arg2);
  1723.  
  1724.     /* apply the test function */
  1725.     val = xlapply(fcn,args.n_ptr);
  1726.  
  1727.     /* restore the previous stack frame */
  1728.     xlstack = oldstk;
  1729.  
  1730.     /* return the result of the test */
  1731.     return (val != NIL);
  1732. }
  1733.  
  1734. /* xnth - return the nth element of a list */
  1735. NODE *xnth(args)
  1736.   NODE *args;
  1737. {
  1738.     return (nth(args,FALSE));
  1739. }
  1740.  
  1741. /* xnthcdr - return the nth cdr of a list */
  1742. NODE *xnthcdr(args)
  1743.   NODE *args;
  1744. {
  1745.     return (nth(args,TRUE));
  1746. }
  1747.  
  1748. /* nth - internal nth function */
  1749. LOCAL NODE *nth(args,cdrflag)
  1750.   NODE *args; int cdrflag;
  1751. {
  1752.     NODE *list;
  1753.     int n;
  1754.  
  1755.     /* get n and the list */
  1756.     if ((n = xlmatch(INT,&args)->n_int) < 0)
  1757.     xlfail("bad argument");
  1758.     if ((list = xlmatch(LIST,&args)) == NIL)
  1759.     xlfail("bad argument");
  1760.     xllastarg(args);
  1761.  
  1762.     /* find the nth element */
  1763.     for (; n > 0 && consp(list); n--)
  1764.     list = cdr(list);
  1765.  
  1766.     /* return the list beginning at the nth element */
  1767.     return (cdrflag || !consp(list) ? list : car(list));
  1768. }
  1769.  
  1770. /* xlength - return the length of a list */
  1771. NODE *xlength(args)
  1772.   NODE *args;
  1773. {
  1774.     NODE *list,*val;
  1775.     int n;
  1776.  
  1777.     /* get the list */
  1778.     list = xlmatch(LIST,&args);
  1779.     xllastarg(args);
  1780.  
  1781.     /* find the length */
  1782.     for (n = 0; consp(list); n++)
  1783.     list = cdr(list);
  1784.  
  1785.     /* create the value node */
  1786.     val = newnode(INT);
  1787.     val->n_int = n;
  1788.  
  1789.     /* return the length */
  1790.     return (val);
  1791. }
  1792.  
  1793. /* xmapc - built-in function 'mapc' */
  1794. NODE *xmapc(args)
  1795.   NODE *args;
  1796. {
  1797.     return (map(args,TRUE,FALSE));
  1798. }
  1799.  
  1800. /* xmapcar - built-in function 'mapcar' */
  1801. NODE *xmapcar(args)
  1802.   NODE *args;
  1803. {
  1804.     return (map(args,TRUE,TRUE));
  1805. }
  1806.  
  1807. /* xmapl - built-in function 'mapl' */
  1808. NODE *xmapl(args)
  1809.   NODE *args;
  1810. {
  1811.     return (map(args,FALSE,FALSE));
  1812. }
  1813.  
  1814. /* xmaplist - built-in function 'maplist' */
  1815. NODE *xmaplist(args)
  1816.   NODE *args;
  1817. {
  1818.     return (map(args,FALSE,TRUE));
  1819. }
  1820.  
  1821. /* map - internal mapping function */
  1822. LOCAL NODE *map(args,carflag,valflag)
  1823.   NODE *args; int carflag,valflag;
  1824. {
  1825.     NODE *oldstk,fcn,lists,arglist,val,*last,*p,*x,*y;
  1826.  
  1827.     /* create a new stack frame */
  1828.     oldstk = xlsave(&fcn,&lists,&arglist,&val,NULL);
  1829.  
  1830.     /* get the function to apply and the first list */
  1831.     fcn.n_ptr = xlarg(&args);
  1832.     lists.n_ptr = xlmatch(LIST,&args);
  1833.  
  1834.     /* save the first list if not saving function values */
  1835.     if (!valflag)
  1836.     val.n_ptr = lists.n_ptr;
  1837.  
  1838.     /* set up the list of argument lists */
  1839.     p = newnode(LIST);
  1840.     rplaca(p,lists.n_ptr);
  1841.     lists.n_ptr = p;
  1842.  
  1843.     /* get the remaining argument lists */
  1844.     while (args) {
  1845.     p = newnode(LIST);
  1846.     rplacd(p,lists.n_ptr);
  1847.     lists.n_ptr = p;
  1848.     rplaca(p,xlmatch(LIST,&args));
  1849.     }
  1850.  
  1851.     /* if the function is a symbol, get its value */
  1852.     if (symbolp(fcn.n_ptr))
  1853.     fcn.n_ptr = xleval(fcn.n_ptr);
  1854.  
  1855.     /* loop through each of the argument lists */
  1856.     for (;;) {
  1857.  
  1858.     /* build an argument list from the sublists */
  1859.     arglist.n_ptr = NIL;
  1860.     for (x = lists.n_ptr; x && (y = car(x)) && consp(y); x = cdr(x)) {
  1861.         p = newnode(LIST);
  1862.         rplacd(p,arglist.n_ptr);
  1863.         arglist.n_ptr = p;
  1864.         rplaca(p,carflag ? car(y) : y);
  1865.         rplaca(x,cdr(y));
  1866.     }
  1867.  
  1868.     /* quit if any of the lists were empty */
  1869.     if (x) break;
  1870.  
  1871.     /* apply the function to the arguments */
  1872.     if (valflag) {
  1873.         p = newnode(LIST);
  1874.         if (val.n_ptr) rplacd(last,p);
  1875.         else val.n_ptr = p;
  1876.         rplaca(p,xlapply(fcn.n_ptr,arglist.n_ptr));
  1877.         last = p;
  1878.     }
  1879.     else
  1880.         xlapply(fcn.n_ptr,arglist.n_ptr);
  1881.     }
  1882.  
  1883.     /* restore the previous stack frame */
  1884.     xlstack = oldstk;
  1885.  
  1886.     /* return the last test expression value */
  1887.     return (val.n_ptr);
  1888. }
  1889.  
  1890. /* xrplca - replace the car of a list node */
  1891. NODE *xrplca(args)
  1892.   NODE *args;
  1893. {
  1894.     NODE *list,*newcar;
  1895.  
  1896.     /* get the list and the new car */
  1897.     if ((list = xlmatch(LIST,&args)) == NIL)
  1898.     xlfail("bad argument");
  1899.     newcar = xlarg(&args);
  1900.     xllastarg(args);
  1901.  
  1902.     /* replace the car */
  1903.     rplaca(list,newcar);
  1904.  
  1905.     /* return the list node that was modified */
  1906.     return (list);
  1907. }
  1908.  
  1909. /* xrplcd - replace the cdr of a list node */
  1910. NODE *xrplcd(args)
  1911.   NODE *args;
  1912. {
  1913.     NODE *list,*newcdr;
  1914.  
  1915.     /* get the list and the new cdr */
  1916.     if ((list = xlmatch(LIST,&args)) == NIL)
  1917.     xlfail("bad argument");
  1918.     newcdr = xlarg(&args);
  1919.     xllastarg(args);
  1920.  
  1921.     /* replace the cdr */
  1922.     rplacd(list,newcdr);
  1923.  
  1924.     /* return the list node that was modified */
  1925.     return (list);
  1926. }
  1927.  
  1928. /* xnconc - destructively append lists */
  1929. NODE *xnconc(args)
  1930.   NODE *args;
  1931. {
  1932.     NODE *list,*last,*val;
  1933.  
  1934.     /* concatenate each argument */
  1935.     for (val = NIL; args; ) {
  1936.  
  1937.     /* concatenate this list */
  1938.     if (list = xlmatch(LIST,&args)) {
  1939.  
  1940.         /* check for this being the first non-empty list */
  1941.         if (val)
  1942.         rplacd(last,list);
  1943.         else
  1944.         val = list;
  1945.  
  1946.         /* find the end of the list */
  1947.         while (consp(cdr(list)))
  1948.         list = cdr(list);
  1949.  
  1950.         /* save the new last element */
  1951.         last = list;
  1952.     }
  1953.     }
  1954.  
  1955.     /* return the list */
  1956.     return (val);
  1957. }
  1958.  
  1959. /* xdelete - built-in function 'delete' */
  1960. NODE *xdelete(args)
  1961.   NODE *args;
  1962. {
  1963.     NODE *oldstk,x,list,fcn,*last,*val;
  1964.     int tresult;
  1965.  
  1966.     /* create a new stack frame */
  1967.     oldstk = xlsave(&x,&list,&fcn,NULL);
  1968.  
  1969.     /* get the expression to delete and the list */
  1970.     x.n_ptr = xlarg(&args);
  1971.     list.n_ptr = xlmatch(LIST,&args);
  1972.     xltest(&fcn.n_ptr,&tresult,&args);
  1973.     xllastarg(args);
  1974.  
  1975.     /* delete leading matches */
  1976.     while (consp(list.n_ptr)) {
  1977.     if (dotest(x.n_ptr,car(list.n_ptr),fcn.n_ptr) != tresult)
  1978.         break;
  1979.     list.n_ptr = cdr(list.n_ptr);
  1980.     }
  1981.     val = last = list.n_ptr;
  1982.  
  1983.     /* delete embedded matches */
  1984.     if (consp(list.n_ptr)) {
  1985.  
  1986.     /* skip the first non-matching element */
  1987.     list.n_ptr = cdr(list.n_ptr);
  1988.  
  1989.     /* look for embedded matches */
  1990.     while (consp(list.n_ptr)) {
  1991.  
  1992.         /* check to see if this element should be deleted */
  1993.         if (dotest(x.n_ptr,car(list.n_ptr),fcn.n_ptr) == tresult)
  1994.         rplacd(last,cdr(list.n_ptr));
  1995.         else
  1996.         last = list.n_ptr;
  1997.  
  1998.         /* move to the next element */
  1999.         list.n_ptr = cdr(list.n_ptr);
  2000.      }
  2001.     }
  2002.  
  2003.     /* restore the previous stack frame */
  2004.     xlstack = oldstk;
  2005.  
  2006.     /* return the updated list */
  2007.     return (val);
  2008. }
  2009.  
  2010. /* xatom - is this an atom? */
  2011. NODE *xatom(args)
  2012.   NODE *args;
  2013. {
  2014.     NODE *arg;
  2015.     arg = xlarg(&args);
  2016.     xllastarg(args);
  2017.     return (atom(arg) ? true : NIL);
  2018. }
  2019.  
  2020. /* xsymbolp - is this an symbol? */
  2021. NODE *xsymbolp(args)
  2022.   NODE *args;
  2023. {
  2024.     NODE *arg;
  2025.     arg = xlarg(&args);
  2026.     xllastarg(args);
  2027.     return (arg == NIL || symbolp(arg) ? true : NIL);
  2028. }
  2029.  
  2030. /* xnumberp - is this an number? */
  2031. NODE *xnumberp(args)
  2032.   NODE *args;
  2033. {
  2034.     NODE *arg;
  2035.     arg = xlarg(&args);
  2036.     xllastarg(args);
  2037.     return (fixp(arg) ? true : NIL);
  2038. }
  2039.  
  2040. /* xboundp - is this a value bound to this symbol? */
  2041. NODE *xboundp(args)
  2042.   NODE *args;
  2043. {
  2044.     NODE *sym;
  2045.     sym = xlmatch(SYM,&args);
  2046.     xllastarg(args);
  2047.     return (sym->n_symvalue == s_unbound ? NIL : true);
  2048. }
  2049.  
  2050. /* xnull - is this null? */
  2051. NODE *xnull(args)
  2052.   NODE *args;
  2053. {
  2054.     NODE *arg;
  2055.     arg = xlarg(&args);
  2056.     xllastarg(args);
  2057.     return (null(arg) ? true : NIL);
  2058. }
  2059.  
  2060. /* xlistp - is this a list? */
  2061. NODE *xlistp(args)
  2062.   NODE *args;
  2063. {
  2064.     NODE *arg;
  2065.     arg = xlarg(&args);
  2066.     xllastarg(args);
  2067.     return (listp(arg) ? true : NIL);
  2068. }
  2069.  
  2070. /* xconsp - is this a cons? */
  2071. NODE *xconsp(args)
  2072.   NODE *args;
  2073. {
  2074.     NODE *arg;
  2075.     arg = xlarg(&args);
  2076.     xllastarg(args);
  2077.     return (consp(arg) ? true : NIL);
  2078. }
  2079.  
  2080. /* xeq - are these equal? */
  2081. NODE *xeq(args)
  2082.   NODE *args;
  2083. {
  2084.     return (cequal(args,eq));
  2085. }
  2086.  
  2087. /* xeql - are these equal? */
  2088. NODE *xeql(args)
  2089.   NODE *args;
  2090. {
  2091.     return (cequal(args,eql));
  2092. }
  2093.  
  2094. /* xequal - are these equal? */
  2095. NODE *xequal(args)
  2096.   NODE *args;
  2097. {
  2098.     return (cequal(args,equal));
  2099. }
  2100.  
  2101. /* cequal - common eq/eql/equal function */
  2102. LOCAL NODE *cequal(args,fcn)
  2103.   NODE *args; int (*fcn)();
  2104. {
  2105.     NODE *arg1,*arg2;
  2106.  
  2107.     /* get the two arguments */
  2108.     arg1 = xlarg(&args);
  2109.     arg2 = xlarg(&args);
  2110.     xllastarg(args);
  2111.  
  2112.     /* compare the arguments */
  2113.     return ((*fcn)(arg1,arg2) ? true : NIL);
  2114. }
  2115. SHAR_EOF
  2116. if test 17752 -ne "`wc -c < 'xllist.c'`"
  2117. then
  2118.     echo shar: error transmitting "'xllist.c'" '(should have been 17752 characters)'
  2119. fi
  2120. fi # end of overwriting check
  2121. echo shar: extracting "'xlobj.c'" '(16101 characters)'
  2122. if test -f 'xlobj.c'
  2123. then
  2124.     echo shar: will not over-write existing file "'xlobj.c'"
  2125. else
  2126. sed 's/^X//' << \SHAR_EOF > 'xlobj.c'
  2127. /* xlobj - xlisp object functions */
  2128.  
  2129. #include "xlisp.h"
  2130.  
  2131. #ifdef MEGAMAX
  2132. overlay "overflow"
  2133. #endif
  2134.  
  2135. /* external variables */
  2136. extern NODE *xlstack;
  2137. extern NODE *xlenv,*xlnewenv;
  2138. extern NODE *s_stdout;
  2139. extern NODE *self;
  2140. extern NODE *class;
  2141. extern NODE *object;
  2142. extern NODE *new;
  2143. extern NODE *isnew;
  2144. extern NODE *msgcls;
  2145. extern NODE *msgclass;
  2146. extern int varcnt;
  2147.  
  2148. /* instance variable numbers for the class 'Class' */
  2149. #define MESSAGES    0    /* list of messages */
  2150. #define IVARS        1    /* list of instance variable names */
  2151. #define CVARS        2    /* list of class variable names */
  2152. #define CVALS        3    /* list of class variable values */
  2153. #define SUPERCLASS    4    /* pointer to the superclass */
  2154. #define IVARCNT        5    /* number of class instance variables */
  2155. #define IVARTOTAL    6    /* total number of instance variables */
  2156.  
  2157. /* number of instance variables for the class 'Class' */
  2158. #define CLASSSIZE    7
  2159.  
  2160. /* forward declarations */
  2161. XFORWARD NODE *xlgetivar();
  2162. XFORWARD NODE *xlsetivar();
  2163. XFORWARD NODE *xlivar();
  2164. XFORWARD NODE *xlcvar();
  2165. XFORWARD NODE *findmsg();
  2166. XFORWARD NODE *findvar();
  2167. XFORWARD NODE *defvars();
  2168. XFORWARD NODE *makelist();
  2169.  
  2170. /* xlclass - define a class */
  2171. NODE *xlclass(name,vcnt)
  2172.   char *name; int vcnt;
  2173. {
  2174.     NODE *sym,*cls;
  2175.  
  2176.     /* create the class */
  2177.     sym = xlsenter(name);
  2178.     cls = sym->n_symvalue = newnode(OBJ);
  2179.     cls->n_obclass = class;
  2180.     cls->n_obdata = makelist(CLASSSIZE);
  2181.  
  2182.     /* set the instance variable counts */
  2183.     if (vcnt > 0) {
  2184.     xlsetivar(cls,IVARCNT,newnode(INT))->n_int = vcnt;
  2185.     xlsetivar(cls,IVARTOTAL,newnode(INT))->n_int = vcnt;
  2186.     }
  2187.  
  2188.     /* set the superclass to 'Object' */
  2189.     xlsetivar(cls,SUPERCLASS,object);
  2190.  
  2191.     /* return the new class */
  2192.     return (cls);
  2193. }
  2194.  
  2195. /* xlmfind - find the message binding for a message to an object */
  2196. NODE *xlmfind(obj,msym)
  2197.   NODE *obj,*msym;
  2198. {
  2199.     return (findmsg(obj->n_obclass,msym));
  2200. }
  2201.  
  2202. /* xlxsend - send a message to an object */
  2203. NODE *xlxsend(obj,msg,args)
  2204.   NODE *obj,*msg,*args;
  2205. {
  2206.     NODE *oldstk,*oldenv,*oldnewenv,method,cptr,eargs,val,*isnewmsg;
  2207.  
  2208.     /* save the old environment */
  2209.     oldnewenv = xlnewenv; oldenv = xlnewenv = xlenv;
  2210.  
  2211.     /* create a new stack frame */
  2212.     oldstk = xlsave(&method,&cptr,&eargs,&val,NULL);
  2213.  
  2214.     /* get the method for this message */
  2215.     method.n_ptr = cdr(msg);
  2216.  
  2217.     /* make sure its a function or a subr */
  2218.     if (!subrp(method.n_ptr) && !consp(method.n_ptr))
  2219.     xlfail("bad method");
  2220.  
  2221.     /* bind the symbols 'self' and 'msgclass' */
  2222.     xlbind(self,obj);
  2223.     xlbind(msgclass,msgcls);
  2224.  
  2225.     /* evaluate the function call */
  2226.     eargs.n_ptr = xlevlist(args);
  2227.     if (subrp(method.n_ptr)) {
  2228.     xlfixbindings();
  2229.     val.n_ptr = (*method.n_ptr->n_subr)(eargs.n_ptr);
  2230.     }
  2231.     else {
  2232.  
  2233.     /* bind the formal arguments */
  2234.     xlabind(car(method.n_ptr),eargs.n_ptr);
  2235.     xlfixbindings();
  2236.  
  2237.     /* execute the code */
  2238.     cptr.n_ptr = cdr(method.n_ptr);
  2239.     while (cptr.n_ptr != NIL)
  2240.         val.n_ptr = xlevarg(&cptr.n_ptr);
  2241.     }
  2242.  
  2243.     /* restore the environment */
  2244.     xlunbind(oldenv); xlnewenv = oldnewenv;
  2245.  
  2246.     /* after creating an object, send it the "isnew" message */
  2247.     if (car(msg) == new && val.n_ptr != NIL) {
  2248.     if ((isnewmsg = xlmfind(val.n_ptr,isnew)) == NIL)
  2249.         xlfail("no method for the isnew message");
  2250.     val.n_ptr = xlxsend(val.n_ptr,isnewmsg,args);
  2251.     }
  2252.  
  2253.     /* restore the previous stack frame */
  2254.     xlstack = oldstk;
  2255.  
  2256.     /* return the result value */
  2257.     return (val.n_ptr);
  2258. }
  2259.  
  2260. /* xlsend - send a message to an object (message in arg list) */
  2261. NODE *xlsend(obj,args)
  2262.   NODE *obj,*args;
  2263. {
  2264.     NODE *msg;
  2265.  
  2266.     /* find the message binding for this message */
  2267.     if ((msg = xlmfind(obj,xlevmatch(SYM,&args))) == NIL)
  2268.     xlfail("no method for this message");
  2269.  
  2270.     /* send the message */
  2271.     return (xlxsend(obj,msg,args));
  2272. }
  2273.  
  2274. /* xlobsym - find a class or instance variable for the current object */
  2275. NODE *xlobsym(sym)
  2276.   NODE *sym;
  2277. {
  2278.     NODE *obj;
  2279.  
  2280.     if ((obj = self->n_symvalue) != NIL && objectp(obj))
  2281.     return (findvar(obj,sym));
  2282.     else
  2283.     return (NIL);
  2284. }
  2285.  
  2286. /* mnew - create a new object instance */
  2287. LOCAL NODE *mnew()
  2288. {
  2289.     NODE *oldstk,obj,*cls;
  2290.  
  2291.     /* create a new stack frame */
  2292.     oldstk = xlsave(&obj,NULL);
  2293.  
  2294.     /* get the class */
  2295.     cls = self->n_symvalue;
  2296.  
  2297.     /* generate a new object */
  2298.     obj.n_ptr = newnode(OBJ);
  2299.     obj.n_ptr->n_obclass = cls;
  2300.     obj.n_ptr->n_obdata = makelist(getivcnt(cls,IVARTOTAL));
  2301.  
  2302.     /* restore the previous stack frame */
  2303.     xlstack = oldstk;
  2304.  
  2305.     /* return the new object */
  2306.     return (obj.n_ptr);
  2307. }
  2308.  
  2309. /* misnew - initialize a new class */
  2310. LOCAL NODE *misnew(args)
  2311.   NODE *args;
  2312. {
  2313.     NODE *oldstk,super,*obj;
  2314.  
  2315.     /* create a new stack frame */
  2316.     oldstk = xlsave(&super,NULL);
  2317.  
  2318.     /* get the superclass if there is one */
  2319.     if (args != NIL)
  2320.     super.n_ptr = xlmatch(OBJ,&args);
  2321.     else
  2322.     super.n_ptr = object;
  2323.     xllastarg(args);
  2324.  
  2325.     /* get the object */
  2326.     obj = self->n_symvalue;
  2327.  
  2328.     /* store the superclass */
  2329.     xlsetivar(obj,SUPERCLASS,super.n_ptr);
  2330.     xlsetivar(obj,IVARTOTAL,newnode(INT))->n_int =
  2331.         getivcnt(super.n_ptr,IVARTOTAL);
  2332.  
  2333.     /* restore the previous stack frame */
  2334.     xlstack = oldstk;
  2335.  
  2336.     /* return the new object */
  2337.     return (obj);
  2338. }
  2339.  
  2340. /* xladdivar - enter an instance variable */
  2341. xladdivar(cls,var)
  2342.   NODE *cls; char *var;
  2343. {
  2344.     NODE *ivar,*lptr;
  2345.  
  2346.     /* find the 'ivars' instance variable */
  2347.     ivar = xlivar(cls,IVARS);
  2348.  
  2349.     /* add the instance variable */
  2350.     lptr = newnode(LIST);
  2351.     rplacd(lptr,car(ivar));
  2352.     rplaca(ivar,lptr);
  2353.     rplaca(lptr,xlsenter(var));
  2354. }
  2355.  
  2356. /* entermsg - add a message to a class */
  2357. LOCAL NODE *entermsg(cls,msg)
  2358.   NODE *cls,*msg;
  2359. {
  2360.     NODE *ivar,*lptr,*mptr;
  2361.  
  2362.     /* find the 'messages' instance variable */
  2363.     ivar = xlivar(cls,MESSAGES);
  2364.  
  2365.     /* lookup the message */
  2366.     for (lptr = car(ivar); lptr != NIL; lptr = cdr(lptr))
  2367.     if (car(mptr = car(lptr)) == msg)
  2368.         return (mptr);
  2369.  
  2370.     /* allocate a new message entry if one wasn't found */
  2371.     lptr = newnode(LIST);
  2372.     rplacd(lptr,car(ivar));
  2373.     rplaca(ivar,lptr);
  2374.     rplaca(lptr,mptr = newnode(LIST));
  2375.     rplaca(mptr,msg);
  2376.  
  2377.     /* return the symbol node */
  2378.     return (mptr);
  2379. }
  2380.  
  2381. /* answer - define a method for answering a message */
  2382. LOCAL NODE *answer(args)
  2383.   NODE *args;
  2384. {
  2385.     NODE *oldstk,arg,msg,fargs,code;
  2386.     NODE *obj,*mptr,*fptr;
  2387.  
  2388.     /* create a new stack frame */
  2389.     oldstk = xlsave(&arg,&msg,&fargs,&code,NULL);
  2390.  
  2391.     /* initialize */
  2392.     arg.n_ptr = args;
  2393.  
  2394.     /* message symbol, formal argument list and code */
  2395.     msg.n_ptr = xlmatch(SYM,&arg.n_ptr);
  2396.     fargs.n_ptr = xlmatch(LIST,&arg.n_ptr);
  2397.     code.n_ptr = xlmatch(LIST,&arg.n_ptr);
  2398.     xllastarg(arg.n_ptr);
  2399.  
  2400.     /* get the object node */
  2401.     obj = self->n_symvalue;
  2402.  
  2403.     /* make a new message list entry */
  2404.     mptr = entermsg(obj,msg.n_ptr);
  2405.  
  2406.     /* setup the message node */
  2407.     rplacd(mptr,fptr = newnode(LIST));
  2408.     rplaca(fptr,fargs.n_ptr);
  2409.     rplacd(fptr,code.n_ptr);
  2410.  
  2411.     /* restore the previous stack frame */
  2412.     xlstack = oldstk;
  2413.  
  2414.     /* return the object */
  2415.     return (obj);
  2416. }
  2417.  
  2418. /* mivars - define the list of instance variables */
  2419. LOCAL NODE *mivars(args)
  2420.   NODE *args;
  2421. {
  2422.     NODE *cls,*super;
  2423.     int scnt;
  2424.  
  2425.     /* define the list of instance variables */
  2426.     cls = defvars(args,IVARS);
  2427.  
  2428.     /* get the superclass instance variable count */
  2429.     if ((super = xlgetivar(cls,SUPERCLASS)) != NIL)
  2430.     scnt = getivcnt(super,IVARTOTAL);
  2431.     else
  2432.     scnt = 0;
  2433.  
  2434.     /* save the number of instance variables */
  2435.     xlsetivar(cls,IVARCNT,newnode(INT))->n_int = varcnt;
  2436.     xlsetivar(cls,IVARTOTAL,newnode(INT))->n_int = scnt+varcnt;
  2437.  
  2438.     /* return the class */
  2439.     return (cls);
  2440. }
  2441.  
  2442. /* getivcnt - get the number of instance variables for a class */
  2443. LOCAL int getivcnt(cls,ivar)
  2444.   NODE *cls; int ivar;
  2445. {
  2446.     NODE *cnt;
  2447.  
  2448.     if ((cnt = xlgetivar(cls,ivar)) != NIL)
  2449.     if (fixp(cnt))
  2450.         return (cnt->n_int);
  2451.     else
  2452.         xlfail("bad value for instance variable count");
  2453.     else
  2454.     return (0);
  2455. }
  2456.  
  2457. /* mcvars - define the list of class variables */
  2458. LOCAL NODE *mcvars(args)
  2459.   NODE *args;
  2460. {
  2461.     NODE *cls;
  2462.  
  2463.     /* define the list of class variables */
  2464.     cls = defvars(args,CVARS);
  2465.  
  2466.     /* make a new list of values */
  2467.     xlsetivar(cls,CVALS,makelist(varcnt));
  2468.  
  2469.     /* return the class */
  2470.     return (cls);
  2471. }
  2472.  
  2473. /* defvars - define a class or instance variable list */
  2474. LOCAL NODE *defvars(args,varnum)
  2475.   NODE *args; int varnum;
  2476. {
  2477.     NODE *oldstk,vars,*vptr,*cls,*sym;
  2478.  
  2479.     /* create a new stack frame */
  2480.     oldstk = xlsave(&vars,NULL);
  2481.  
  2482.     /* get ivar list */
  2483.     vars.n_ptr = xlmatch(LIST,&args);
  2484.     xllastarg(args);
  2485.  
  2486.     /* get the class node */
  2487.     cls = self->n_symvalue;
  2488.  
  2489.     /* check each variable in the list */
  2490.     varcnt = 0;
  2491.     for (vptr = vars.n_ptr;
  2492.      consp(vptr);
  2493.      vptr = cdr(vptr)) {
  2494.  
  2495.     /* make sure this is a valid symbol in the list */
  2496.     if ((sym = car(vptr)) == NIL || !symbolp(sym))
  2497.         xlfail("bad variable list");
  2498.  
  2499.     /* make sure its not already defined */
  2500.     if (checkvar(cls,sym))
  2501.         xlfail("multiply defined variable");
  2502.  
  2503.     /* count the variable */
  2504.     varcnt++;
  2505.     }
  2506.  
  2507.     /* make sure the list ended properly */
  2508.     if (vptr != NIL)
  2509.     xlfail("bad variable list");
  2510.  
  2511.     /* define the new variable list */
  2512.     xlsetivar(cls,varnum,vars.n_ptr);
  2513.  
  2514.     /* restore the previous stack frame */
  2515.     xlstack = oldstk;
  2516.  
  2517.     /* return the class */
  2518.     return (cls);
  2519. }
  2520.  
  2521. /* xladdmsg - add a message to a class */
  2522. xladdmsg(cls,msg,code)
  2523.   NODE *cls; char *msg; NODE *(*code)();
  2524. {
  2525.     NODE *mptr;
  2526.  
  2527.     /* enter the message selector */
  2528.     mptr = entermsg(cls,xlsenter(msg));
  2529.  
  2530.     /* store the method for this message */
  2531.     rplacd(mptr,newnode(SUBR));
  2532.     cdr(mptr)->n_subr = code;
  2533. }
  2534.  
  2535. /* getclass - get the class of an object */
  2536. LOCAL NODE *getclass(args)
  2537.   NODE *args;
  2538. {
  2539.     /* make sure there aren't any arguments */
  2540.     xllastarg(args);
  2541.  
  2542.     /* return the object's class */
  2543.     return (self->n_symvalue->n_obclass);
  2544. }
  2545.  
  2546. /* obshow - show the instance variables of an object */
  2547. LOCAL NODE *obshow(args)
  2548.   NODE *args;
  2549. {
  2550.     NODE *fptr;
  2551.  
  2552.     /* get the file pointer */
  2553.     fptr = (args ? xlmatch(FPTR,&args) : s_stdout->n_symvalue);
  2554.     xllastarg(args);
  2555.  
  2556.     /* print the object's instance variables */
  2557.     xlprint(fptr,self->n_symvalue->n_obdata,TRUE);
  2558.     xlterpri(fptr);
  2559.  
  2560.     /* return the object */
  2561.     return (self->n_symvalue);
  2562. }
  2563.  
  2564. /* defisnew - default 'isnew' method */
  2565. LOCAL NODE *defisnew(args)
  2566.   NODE *args;
  2567. {
  2568.     /* make sure there aren't any arguments */
  2569.     xllastarg(args);
  2570.  
  2571.     /* return the object */
  2572.     return (self->n_symvalue);
  2573. }
  2574.  
  2575. /* sendsuper - send a message to an object's superclass */
  2576. LOCAL NODE *sendsuper(args)
  2577.   NODE *args;
  2578. {
  2579.     NODE *obj,*super,*msg;
  2580.  
  2581.     /* get the object */
  2582.     obj = self->n_symvalue;
  2583.  
  2584.     /* get the object's superclass */
  2585.     super = xlgetivar(obj->n_obclass,SUPERCLASS);
  2586.  
  2587.     /* find the message binding for this message */
  2588.     if ((msg = findmsg(super,xlmatch(SYM,&args))) == NIL)
  2589.     xlfail("no method for this message");
  2590.  
  2591.     /* send the message */
  2592.     return (xlxsend(obj,msg,args));
  2593. }
  2594.  
  2595. /* findmsg - find the message binding given an object and a class */
  2596. LOCAL NODE *findmsg(cls,sym)
  2597.   NODE *cls,*sym;
  2598. {
  2599.     NODE *lptr,*msg;
  2600.  
  2601.     /* start at the specified class */
  2602.     msgcls = cls;
  2603.  
  2604.     /* look for the message in the class or superclasses */
  2605.     while (msgcls != NIL) {
  2606.  
  2607.     /* lookup the message in this class */
  2608.     for (lptr = xlgetivar(msgcls,MESSAGES);
  2609.          lptr != NIL;
  2610.          lptr = cdr(lptr))
  2611.         if ((msg = car(lptr)) != NIL && car(msg) == sym)
  2612.         return (msg);
  2613.  
  2614.     /* look in class's superclass */
  2615.     msgcls = xlgetivar(msgcls,SUPERCLASS);
  2616.     }
  2617.  
  2618.     /* message not found */
  2619.     return (NIL);
  2620. }
  2621.  
  2622. /* findvar - find a class or instance variable */
  2623. LOCAL NODE *findvar(obj,sym)
  2624.   NODE *obj,*sym;
  2625. {
  2626.     NODE *cls,*lptr;
  2627.     int base,varnum;
  2628.     int found;
  2629.  
  2630.     /* get the class of the object */
  2631.     cls = obj->n_obclass;
  2632.  
  2633.     /* get the total number of instance variables */
  2634.     base = getivcnt(cls,IVARTOTAL);
  2635.  
  2636.     /* find the variable */
  2637.     found = FALSE;
  2638.     for (; cls != NIL; cls = xlgetivar(cls,SUPERCLASS)) {
  2639.  
  2640.     /* get the number of instance variables for this class */
  2641.     if ((base -= getivcnt(cls,IVARCNT)) < 0)
  2642.         xlfail("error finding instance variable");
  2643.  
  2644.     /* check for finding the class of the current message */
  2645.     if (!found && cls == msgclass->n_symvalue)
  2646.         found = TRUE;
  2647.  
  2648.     /* lookup the instance variable */
  2649.     varnum = 0;
  2650.     for (lptr = xlgetivar(cls,IVARS);
  2651.              lptr != NIL;
  2652.              lptr = cdr(lptr))
  2653.         if (found && car(lptr) == sym)
  2654.         return (xlivar(obj,base + varnum));
  2655.         else
  2656.         varnum++;
  2657.  
  2658.     /* skip the class variables if the message class hasn't been found */
  2659.     if (!found)
  2660.         continue;
  2661.  
  2662.     /* lookup the class variable */
  2663.     varnum = 0;
  2664.     for (lptr = xlgetivar(cls,CVARS);
  2665.              lptr != NIL;
  2666.              lptr = cdr(lptr))
  2667.         if (car(lptr) == sym)
  2668.         return (xlcvar(cls,varnum));
  2669.         else
  2670.         varnum++;
  2671.     }
  2672.  
  2673.     /* variable not found */
  2674.     return (NIL);
  2675. }
  2676.  
  2677. /* checkvar - check for an existing class or instance variable */
  2678. LOCAL int checkvar(cls,sym)
  2679.   NODE *cls,*sym;
  2680. {
  2681.     NODE *lptr;
  2682.  
  2683.     /* find the variable */
  2684.     for (; cls != NIL; cls = xlgetivar(cls,SUPERCLASS)) {
  2685.  
  2686.     /* lookup the instance variable */
  2687.     for (lptr = xlgetivar(cls,IVARS);
  2688.              lptr != NIL;
  2689.              lptr = cdr(lptr))
  2690.         if (car(lptr) == sym)
  2691.         return (TRUE);
  2692.  
  2693.     /* lookup the class variable */
  2694.     for (lptr = xlgetivar(cls,CVARS);
  2695.              lptr != NIL;
  2696.              lptr = cdr(lptr))
  2697.         if (car(lptr) == sym)
  2698.         return (TRUE);
  2699.     }
  2700.  
  2701.     /* variable not found */
  2702.     return (FALSE);
  2703. }
  2704.  
  2705. /* xlgetivar - get the value of an instance variable */
  2706. NODE *xlgetivar(obj,num)
  2707.   NODE *obj; int num;
  2708. {
  2709.     return (car(xlivar(obj,num)));
  2710. }
  2711.  
  2712. /* xlsetivar - set the value of an instance variable */
  2713. NODE *xlsetivar(obj,num,val)
  2714.   NODE *obj; int num; NODE *val;
  2715. {
  2716.     rplaca(xlivar(obj,num),val);
  2717.     return (val);
  2718. }
  2719.  
  2720. /* xlivar - get an instance variable */
  2721. NODE *xlivar(obj,num)
  2722.   NODE *obj; int num;
  2723. {
  2724.     NODE *ivar;
  2725.  
  2726.     /* get the instance variable */
  2727.     for (ivar = obj->n_obdata; num > 0; num--)
  2728.     if (ivar != NIL)
  2729.         ivar = cdr(ivar);
  2730.     else
  2731.         xlfail("bad instance variable list");
  2732.  
  2733.     /* return the instance variable */
  2734.     return (ivar);
  2735. }
  2736.  
  2737. /* xlcvar - get a class variable */
  2738. NODE *xlcvar(cls,num)
  2739.   NODE *cls; int num;
  2740. {
  2741.     NODE *cvar;
  2742.  
  2743.     /* get the class variable */
  2744.     for (cvar = xlgetivar(cls,CVALS); num > 0; num--)
  2745.     if (cvar != NIL)
  2746.         cvar = cdr(cvar);
  2747.     else
  2748.         xlfail("bad class variable list");
  2749.  
  2750.     /* return the class variable */
  2751.     return (cvar);
  2752. }
  2753.  
  2754. /* makelist - make a list of nodes */
  2755. LOCAL NODE *makelist(cnt)
  2756.   int cnt;
  2757. {
  2758.     NODE *oldstk,list,*lnew;
  2759.  
  2760.     /* create a new stack frame */
  2761.     oldstk = xlsave(&list,NULL);
  2762.  
  2763.     /* make the list */
  2764.     for (; cnt > 0; cnt--) {
  2765.     lnew = newnode(LIST);
  2766.     rplacd(lnew,list.n_ptr);
  2767.     list.n_ptr = lnew;
  2768.     }
  2769.  
  2770.     /* restore the previous stack frame */
  2771.     xlstack = oldstk;
  2772.  
  2773.     /* return the list */
  2774.     return (list.n_ptr);
  2775. }
  2776.  
  2777. /* xloinit - object function initialization routine */
  2778. xloinit()
  2779. {
  2780.     /* don't confuse the garbage collector */
  2781.     class = object = NIL;
  2782.  
  2783.     /* enter the object related symbols */
  2784.     new        = xlsenter("new");
  2785.     isnew    = xlsenter("isnew");
  2786.     self    = xlsenter("self");
  2787.     msgclass    = xlsenter("msgclass");
  2788.  
  2789.     /* create the 'Class' object */
  2790.     class = xlclass("Class",CLASSSIZE);
  2791.     class->n_obclass = class;
  2792.  
  2793.     /* create the 'Object' object */
  2794.     object = xlclass("Object",0);
  2795.  
  2796.     /* finish initializing 'class' */
  2797.     xlsetivar(class,SUPERCLASS,object);
  2798.     xladdivar(class,"ivartotal");    /* ivar number 6 */
  2799.     xladdivar(class,"ivarcnt");        /* ivar number 5 */
  2800.     xladdivar(class,"superclass");    /* ivar number 4 */
  2801.     xladdivar(class,"cvals");        /* ivar number 3 */
  2802.     xladdivar(class,"cvars");        /* ivar number 2 */
  2803.     xladdivar(class,"ivars");        /* ivar number 1 */
  2804.     xladdivar(class,"messages");    /* ivar number 0 */
  2805.     xladdmsg(class,"new",mnew);
  2806.     xladdmsg(class,"answer",answer);
  2807.     xladdmsg(class,"ivars",mivars);
  2808.     xladdmsg(class,"cvars",mcvars);
  2809.     xladdmsg(class,"isnew",misnew);
  2810.  
  2811.     /* finish initializing 'object' */
  2812.     xladdmsg(object,"class",getclass);
  2813.     xladdmsg(object,"show",obshow);
  2814.     xladdmsg(object,"isnew",defisnew);
  2815.     xladdmsg(object,"sendsuper",sendsuper);
  2816. }
  2817. SHAR_EOF
  2818. if test 16101 -ne "`wc -c < 'xlobj.c'`"
  2819. then
  2820.     echo shar: error transmitting "'xlobj.c'" '(should have been 16101 characters)'
  2821. fi
  2822. fi # end of overwriting check
  2823. #    End of shell archive
  2824. exit 0
  2825.  
  2826.